home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / comp / primops / new_base.t < prev    next >
Encoding:
Text File  |  1989-06-30  |  7.4 KB  |  213 lines
  1. (herald new_base)
  2.  
  3. ;;; Copyright (c) 1985 Yale University
  4. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  5. ;;; This material was developed by the T Project at the Yale University Computer 
  6. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  7. ;;; and to use it for any purpose is granted, subject to the following restric-
  8. ;;; tions and understandings.
  9. ;;; 1. Any copy made of this software must include this copyright notice in full.
  10. ;;; 2. Users of this software agree to make their best efforts (a) to return
  11. ;;;    to the T Project at Yale any improvements or extensions that they make,
  12. ;;;    so that these may be included in future releases; and (b) to inform
  13. ;;;    the T Project of noteworthy uses of this software.
  14. ;;; 3. All materials developed as a consequence of the use of this software
  15. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  16. ;;;    of acknowledging credit in academic research.
  17. ;;; 4. Yale has made no warrantee or representation that the operation of
  18. ;;;    this software will be error-free, and Yale is under no obligation to
  19. ;;;    provide any services, by way of maintenance, update, or otherwise.
  20. ;;; 5. In conjunction with products arising from the use of this material,
  21. ;;;    there shall be no use of the name of the Yale University nor of any
  22. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  23. ;;;    without prior written consent from Yale in each case.
  24. ;;;
  25.  
  26. (define initial-primop-table
  27.   (make-primop-table 'initial-primop-table))
  28.  
  29. (define *initial-primop-table* initial-primop-table) ;;; compatibility
  30.  
  31. (define initial-primop-env
  32.   (make-support-table 'initial-primop-env initial-primop-table))
  33.  
  34. (define *initial-primop-env* initial-primop-env) ;;; compatibility
  35.  
  36. (define (initial-primop-code name clauses)
  37.   (receive (bitv fields methods)
  38.            (parse-primop-clauses clauses)
  39.     `(make-primop ',name
  40.                   ,bitv
  41.                   '()
  42.                   nil
  43.                   nil
  44.                   (object nil
  45.                     . ,methods)
  46.                   . ,fields)))
  47.  
  48. (define-local-syntax (define-initial-primop id . clauses)
  49.   `(let ((primop ,(initial-primop-code id clauses)))
  50.      (set (primop.environment primop) initial-primop-env)
  51.      (set (initial-primop-table ',id) primop)
  52.      (make-support-entry (create-variable ',id)
  53.                          initial-primop-env
  54.                          '()
  55.                          'constant
  56.                          (node->vector (create-primop-node primop))
  57.                          nil)))
  58.  
  59. ;;; BASIC PRIMOPS
  60. ;;;============================================================================
  61. ;;; These are all known to alphatize, simplify, etc.
  62.  
  63. ;;; Place marking primops
  64. ;;;============================================================================
  65. ;;; These are used by alpha to mark points in the tree.
  66.  
  67. (define-initial-primop undefined)
  68.  
  69. (define-initial-primop *primop
  70.   ((primop.simplify self node)
  71.    (simplify-*primop self node)))
  72.  
  73. (define-initial-primop undefined-effect
  74.   ((primop.side-effects? self) t)
  75.   ((primop.generate self node)
  76.    (generate-undefined-effect node))
  77.   ((primop.special? self) t)
  78.   ((primop.presimplify self node)
  79.    (presimplify-undefined-effect node))
  80.   ((primop.type self node) '(proc (cont) string?)))
  81.  
  82. (define-initial-primop Y
  83.   ((primop.generate self node)
  84.    (generate-labels node))
  85.   ((primop.simplify self node)
  86.    (simplify-y node))
  87.   ((primop.special? self) t))
  88.  
  89. (define-initial-primop conditional
  90.   ((primop.generate self node)
  91.    (primop.generate (primop-value ((call-arg 3) node)) node))
  92.   ((primop.conditional? self) t)
  93.   ((primop.simplify self node)
  94.    (primop.simplify (primop-value ((call-arg 3) node)) node)))
  95.  
  96. (define-initial-primop test
  97.   ((primop.generate self node)
  98.    (destructure (((then else () type arg) (call-args node)))
  99.      (primop.test-code (primop-value type)
  100.                        node
  101.                        (access-value node (leaf-value arg)))
  102.      (if (primop.jump-on-equal? (primop-value type))
  103.          (emit-jump 'jeql else then)       
  104.          (emit-jump 'jneq else then))))
  105.   ((primop.presimplify self node)
  106.    (presimplify-to-conditional node))
  107.   ((primop.simplify self node)
  108.    (simplify-test node))
  109.   ((primop.conditional? self) t))
  110.  
  111. (define-initial-primop true?
  112.   ((primop.test-code self node arg)
  113.    (generate-nil-test arg))
  114.   ((primop.presimplify self node)
  115.    (presimplify-predicate node))           
  116.   ((primop.jump-on-equal? self) t)       ; because we compare with nil
  117.   ((primop.type-predicate? self) t)
  118.   ((primop.type self node) '(proc (cont boolean?) top?)))
  119.  
  120.  
  121. (define-initial-primop *set-var
  122.   ((primop.side-effects? self) t)
  123.   ((primop.generate self node)
  124.    (generate-set node
  125.                  ((call-arg 2) node)
  126.                  ((call-arg 3) node)))
  127.   ((primop.uses-L-value? self) t)
  128.   ((primop.defines-support? self) t)
  129.   ((primop.support-variant self) 'set))
  130.  
  131. (define-initial-primop single-set-var
  132.   ((primop.side-effects? self) t)
  133.   ((primop.generate self node)
  134.    (generate-single-set node
  135.                         ((call-arg 2) node)
  136.                         ((call-arg 3) node)))
  137.   ((primop.uses-L-value? self) t))
  138.  
  139. (define-initial-primop *locative
  140.   ((primop.generate self node)
  141.    (generate-locative node))
  142.   ((primop.support-variant self) 'set)
  143.   ((primop.defines-support? self) t)
  144.   ((primop.uses-L-value? self) t))
  145.  
  146. ;;; Defining primops
  147. ;;;============================================================================
  148. ;;; These assign values to global variables.
  149.  
  150. (define-initial-primop *define
  151.   ((primop.side-effects? self) t)
  152.   ((primop.generate self node)
  153.    (generate-define-var node))
  154.   ((primop.defines-support? self) t)
  155.   ((primop.uses-L-value? self) t)
  156.   ((primop.support-variant self) 'define))
  157.  
  158. (define-initial-primop *lset
  159.   ((primop.side-effects? self) t)
  160.   ((primop.generate self node)
  161.    (generate-define-var node))
  162.   ((primop.defines-support? self) t)
  163.   ((primop.uses-L-value? self) t)
  164.   ((primop.support-variant self) 'lset))
  165.  
  166. (define-initial-primop *define-constant
  167.   ((primop.side-effects? self) t)
  168.   ((primop.generate self node)
  169.    (generate-define-var node))
  170.   ((primop.defines-support? self) t)
  171.   ((primop.uses-L-value? self) t)
  172.   ((primop.support-variant self) 'constant))
  173.  
  174. ;;; To deal with objects and their ilk.
  175. (define-initial-primop proc+handler
  176.   ((primop.support self call)
  177.    (object-support call))
  178.   ((primop.handler? self) t))
  179.  
  180. ;;; The three location primops.  These generate code for locations the same
  181. ;;; way COMPARE does for EQ? etc.
  182. ;;;   (CAR-LOC (LAMBDA (X) (CONTENTS <cont> X) L) =>
  183. ;;;   (CONTENTS-LOCATION <cont> CAR-LOC L)
  184. ;;;
  185. ;;;   (CAR-LOC (LAMBDA (X) (SET-CONTENTS <cont> X A) L) =>
  186. ;;;   (SET-LOCATION <cont> CAR-LOC A L)  ;Value goes before arguments.
  187. ;;;
  188.  
  189. (define-initial-primop contents-location
  190.   ((primop.generate self node)
  191.    (generate-contents-location node)))
  192.  
  193. (define-initial-primop set-location
  194.   ((primop.side-effects? self) t)
  195.   ((primop.generate self node)
  196.    (generate-set-location node)))
  197.  
  198. (define-initial-primop locative-location)
  199.  
  200. (define-initial-primop make-cell
  201.   ((primop.generate self node)
  202.    (generate-make-cell node))
  203.   ((primop.type self node) '(proc (cont cell?) top?)))
  204.  
  205. (define-initial-primop cell-value
  206.   ((primop.location? self) t)
  207.   ((primop.location-specs self) (fx- (fx* 1 4) 2))
  208.   ((primop.rep-wants self) 'rep/pointer)
  209.   ((primop.simplify self node)
  210.    (simplify-location node))
  211.   ((primop.type self node) '(proc (cont top?) cell?)))
  212.  
  213.